 
C type PFPU = record
C               NAME: integer; (* index into NAMTXT *)
C               NARGS: integer;
C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
C               DTYPE: integer;
C               CHRLEN: integer;
C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
C             end;
 
C type PFEX = record
C               NAME: integer;
C               DTYPE: integer;
C               CHRLEN: integer;
C               NARGS: integer;
C               ARGS: ^(heap) HEAD(PFEXARG);
C               INDARG: ^PFPUARG    (* only for indirect refs *)
C             end;
 
C type PFPUARG = record
C                   DTYPE: integer;
C                   CHLEN: integer;
C                   case STRUC of
C                       var,array: (USAGE: (arg,read,update));
C                       proc: (REF: integer (EXNODE index))
C                       end;
C                   STRUC: (var,array,proc);
C                   SIZE: integer;
C                   DESC: ^(heap) HEAD (PUARGDES);
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   PRNTS: ^(heap) HEAD (LATPAR)
C                end;
 
C type PFEXARG = record
C                   DTYPE: integer;
C                   ATYPE: integer;
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   if (DTYPE=type_char) then
C                       CHMIN,CHMAX: integer
C                   end if
C                 end;
 
C type PFPUDESC = record
C                   NODE: integer (* +ve => index into PUNODE,
C                                    -ve => -index into EXNODE *)
C                 end;
C
C type PFPUCU = record
C                   CBNUM: integer; (* index into CBDATA *)
C                   USAGE: (readonly,update)
C               end;
 
C type PUARGDES = record
C                   TYPE: (direct,indirect);
C                   ANUM: integer;  (* argument number passed out as *)
C                   case TYPE of
C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
C                       indirect: (INUM: integer)   (* arg no. passed to *)
C                       end
C                 end;
 
C type PFPROC = record
C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
C                   ASSOC: integer; (* ditto of associating pu. *)
C                   STMTNO: integer (* statement number of association *)
C               end;
 
C
C type PARENT = record (* routine parent *)
C                   NODE: integer   (* PUNODE index of parent routine *)
C               end;
C
C type APARENT = record (* argument parent *)
C                   NODE: integer;  (* PUNODE index of parent routine *)
C                   ANUM: integer   (* argument number passed down *)
C                end;
 
C type PFUS = record (* unsafe reference check record *)
C               TYPE: 1..5;      (* unsafe reference type *)
C               ASSOC: integer;  (* punode index of calling p.u. *)
C               STMTNO: integer; (* statement number of reference *)
C               EXTRA: integer;  (* type-dependent extra data *)
C               CALLED: integer; (* punode/exnode index of called routine *)
C               ARGNUM: integer  (* argument number for unsafe check *)
C             end;
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C ----------------------------------------------------------------------
C
C       P F E T O P   -   Convert EXNODE index to PUNODE index
C
 
        INTEGER FUNCTION PFETOP(ENUM)
        INTEGER ENUM
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
 
        PFETOP=HEAP(EXNODE(ABS(ENUM))+0)
        IF (NAMTXT(PFETOP).EQ.'      ') THEN
            PFETOP=-ABS(ENUM)
        ELSE
            PFETOP=NAMEPU(PFETOP)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F E R R   -   Produce an error message
C
 
        SUBROUTINE PFERR(S,N1,N2,N3,N4)
        CHARACTER*(*) S
        INTEGER N1,N2,N3,N4
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFERRC/NPFERR,NPFWRN
        INTEGER NPFERR,NPFWRN
        SAVE/PFERRC/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
 
        LOGICAL DEBUGM
        PARAMETER (DEBUGM=.FALSE.)
 
        INTEGER I,L,ICNT,INSERT(4),SLEN,NODNAM,TEXT(134),
     +          SYMBOL(8)
        CHARACTER LTYPE
        LOGICAL FIRSTU,FIRSTE
 
        SAVE FIRSTU,FIRSTE,LTYPE
 
        INTRINSIC INDEX,LEN
 
        INTEGER ZYGPUS
        EXTERNAL ZCHOUT,ZMESS,PUTCH,ERROR,ZPTINT,ZYGTSY,ZYGTST,PUTLIN,
     +           ZYGPUS
 
        DATA FIRSTU,FIRSTE/2*.TRUE./,LTYPE/' '/
 
        IF ((S(1:1).EQ.'E' .OR. S(1:1).EQ.'F') .AND. FIRSTE) THEN
            CALL PUTCH(10,2)
            CALL ZMESS('*********************************************',
     +                 2)
            CALL ZMESS('*                                           *',
     +                 2)
            CALL ZMESS('*  Error(s) have been detected by PFORT-77  *',
     +                 2)
            CALL ZMESS('*                                           *',
     +                 2)
            CALL ZMESS('*********************************************',
     +                 2)
            CALL PUTCH(10,2)
            FIRSTE=.FALSE.
        ELSE IF (S(1:1).EQ.'U' .AND. FIRSTU .AND. FIRSTE) THEN
            CALL PUTCH(10,2)
            CALL ZMESS('*******************************',2)
            CALL ZMESS('*                             *',2)
            CALL ZMESS('*  Unsafe Reference(s) found  *',2)
            CALL ZMESS('*                             *',2)
            CALL ZMESS('*******************************',2)
            CALL PUTCH(10,2)
            FIRSTU=.FALSE.
        ELSE IF ((S(1:1).EQ.'D' .OR. S(1:1).EQ.' '.AND.LTYPE.EQ.'D')
     +           .AND. .NOT.DEBUGM) THEN
            LTYPE='D'
            RETURN
        END IF
 
C First: output the error type
        IF (S(1:1).NE.' ') LTYPE=S(1:1)
        IF (S(1:1).EQ.'E') THEN
            CALL ZCHOUT('Error',2)
            NPFERR=NPFERR+1
        ELSE IF (S(1:1).EQ.'W') THEN
            CALL ZCHOUT('Warning',2)
            NPFWRN=NPFWRN+1
        ELSE IF (S(1:1).EQ.'F') THEN
            CALL ZCHOUT('Fatal Error',2)
        ELSE IF (S(1:1).EQ.'I') THEN
            CALL ZCHOUT('Internal Error',2)
        ELSE IF (S(1:1).EQ.'D') THEN
            CALL ZCHOUT('Debugging',2)
        ELSE IF (S(1:1).EQ.'U') THEN
            CALL ZCHOUT('Unsafe',2)
            NPFERR=NPFERR+1
        ELSE IF (S(1:1).EQ.' ') THEN
            IF (LTYPE.EQ.'E') THEN
                CALL ZCHOUT('       ',2)
            ELSE IF (LTYPE.EQ.'W') THEN
                CALL ZCHOUT('         ',2)
            ELSE IF (LTYPE.EQ.'U') THEN
                CALL ZCHOUT('        ',2)
            ELSE IF (LTYPE.EQ.'D') THEN
                CALL ZCHOUT('           ',2)
            END IF
        END IF
 
C Second: begin parsing the error string, looking for key chars
C
C The idea is: '$' in the string signals an insertion, the char
C following specifying what type, i.e.
C   '$I' - "integer" - CALL ZPTINT(N,1,stderr)
C   '$T' - "text"    - CALL ZCHOUT(NAMTXT(N),stderr)
C   '$N' - "node"    - CALL ZCHOUT(NAMTXT(HEAP(N)),stderr)
C   '$S' - "symbol"  - CALL ZYGTSY(N,SYMBOL)
C                      CALL ZYGTST(SYMBOL(symbol_name),TEXT)
C                      CALL PUTLIN(TEXT,stderr)
C   '$P' - "p.u."    - CALL ZYGTSY(ZYGPUS(N),SYMBOL)
C                      CALL ZYGTST(SYMBOL(symbol_name),TEXT)
C                      CALL PUTLIN(TEXT,stderr)
 
        L=2
        I=2
        ICNT=0
        INSERT(1)=N1
        INSERT(2)=N2
        INSERT(3)=N3
        INSERT(4)=N4
 100    IF (S(I:I).NE.'$') THEN
            I=I+1
            IF (I.LT.LEN(S)) GOTO 100
            IF (I.GE.L) CALL ZCHOUT(S(L:I),2)
        ELSE
            IF (I.GT.L) CALL ZCHOUT(S(L:I-1),2)
            I=I+1
            ICNT=ICNT+1
            IF (S(I:I).EQ.'I') THEN
                CALL ZPTINT(INSERT(ICNT),1,2)
            ELSE IF (S(I:I).EQ.'T') THEN
                SLEN=INDEX(NAMTXT(INSERT(ICNT)),' ')-1
                IF (SLEN.LT.0) SLEN=6
                CALL ZCHOUT(NAMTXT(INSERT(ICNT))(:SLEN),2)
            ELSE IF (S(I:I).EQ.'N') THEN
                NODNAM=HEAP(INSERT(ICNT))
                SLEN=INDEX(NAMTXT(NODNAM),' ')-1
                IF (SLEN.LT.0) SLEN=6
                IF (SLEN.EQ.0) THEN
                    CALL ZCHOUT('procedure argument',2)
                ELSE
                    CALL ZCHOUT(NAMTXT(NODNAM)(:SLEN),2)
                END IF
            ELSE IF (S(I:I).EQ.'S') THEN
                CALL ZYGTSY(INSERT(ICNT),SYMBOL)
                CALL ZYGTST(SYMBOL(2),TEXT)
                CALL PUTLIN(TEXT,2)
            ELSE
                CALL ZYGTSY(ZYGPUS(INSERT(ICNT)),SYMBOL)
                CALL ZYGTST(SYMBOL(2),TEXT)
                CALL PUTLIN(TEXT,2)
            END IF
            I=I+1
            L=I
            IF (I.LT.LEN(S)) GOTO 100
            IF (I.EQ.LEN(S)) CALL ZCHOUT(S(I:I),2)
        END IF
        CALL PUTCH(10,2)
 
C Terminate program if required
        IF (S(1:1).EQ.'F') THEN
            CALL ERROR('PFORT-77 terminated by Fatal Error')
        ELSE IF (S(1:1).EQ.'I') THEN
            CALL ERROR('PFORT-77 terminated by Internal Error')
        END IF
 
        END
